PC Answers 1995 May/PC Answers CD-ROM 7 (Future Publishing) (May 1995).iso/vbits/code/appleman/eventmod.bas

BASIC Source File | 1994-10-06 | 10.9 KB | 368 lines

' Eventcod.bas
'
' Sample program exploring how common algorithms can be
' converted to event driven versions for Visual Basic
'
' Copyright (c) 1992, by Desaware
'
'

'   For demo purposes, we load our sample array with
'   numbers 1 through ARRAYSIZE in random order
'
'   First call starts the initialization
'   Returns 0 when initialization is complete, -1 otherwise
'   Next call will start initialization again.
'
Function LoadSampleArray% ()
    Static x%
    Static inprogress%

    Dim temp, pos1%, pos2%, cnt%

    If Not inprogress% Then ' Do this part uninterrupted
        inprogress% = -1
        ' Initialize array values
        For cnt% = 1 To ARRAYSIZE
            SampleArray(cnt%) = cnt%
        Next cnt%
    End If

    ' Now shuffle them to random locations

    For cnt% = 1 To 100
        pos1% = Int(Rnd * ARRAYSIZE + 1)
        pos2% = Int(Rnd * ARRAYSIZE + 1)
        temp = SampleArray(pos1%)
        SampleArray(pos1%) = SampleArray(pos2%)
        SampleArray(pos2%) = temp
        x% = x% + 1
        If x% > ARRAYSIZE Then
            inprogress% = 0
            Exit For
        End If
    Next cnt%
    LoadSampleArray% = inprogress%


End Function

'
'
' -1 if a search the sort is in progress.  The calling
' program will generally keep calling this function until
' it receives a result = 0
'
' On first call, startpos% and endpos% should be set to
'   the start and end positions.
'
' On all further calls, both of these parameters must
'   be set to zero.
'
' Calling this function with startpos% set to -1 aborts
' the current background operation and returns a result
' 1
'
Function QSortBackground% (ByVal startpos%, ByVal endpos%)
Dim splitloc%
Dim sp%, ep%    ' Internal use start & end position
Static startlocs(300) As Integer
Static endlocs(300) As Integer
Static stackptr%
' When the function is cancelled, we clear the stack and
' flag the cancelation for return by the NEXT call -
' this makes it possible for the code that does the cancelation
' to not have to do the timer cleanup.
Static cancelpending%


    If startpos% = -1 Then
        stackptr% = 0
        cancelpending% = -1
        QSortBackground% = -1
        Exit Function
        End If

    If endpos% > 0 Then ' It's the first call
        stackptr% = 0   ' Reinitialize the stack pointer
        ' Set up the stack for the next call
        stackptr% = stackptr% + 1
        startlocs(stackptr%) = startpos%
        endlocs(stackptr%) = endpos%
        QSortBackground% = -1
        Exit Function
        End If

    ' The sort is complete if the stack is empty
    If stackptr% = 0 Then
        If cancelpending% Then QSortBackground% = 1 Else QSortBackground% = 0
        cancelpending% = 0
        Exit Function
        End If

    ' Get the current stack values and pop them off the stack
    sp% = startlocs(stackptr%)
    ep% = endlocs(stackptr%)
    stackptr% = stackptr% - 1

    ' This entry is sorted if the start position is
    ' beyond the end position
    If sp% >= ep% Then
        QSortBackground% = -1
        Exit Function
        End If

    ' Parition the array into two sections
    splitloc% = QSplit%(sp%, ep%)

    ' Now quicksort each of the sections by pushing it
    ' on the stack for the next call

    stackptr% = stackptr% + 1
    startlocs(stackptr%) = splitloc% + 1
    endlocs(stackptr%) = ep%

    stackptr% = stackptr% + 1
    startlocs(stackptr%) = sp%
    endlocs(stackptr%) = splitloc%

    QSortBackground% = -1   ' And continue
End Function

'
' Simple quicksort algorithm without background processing
'
Sub QSortNoEvents (ByVal startpos%, ByVal endpos%)
Dim splitloc%

    ' It's over if the start position is beyond the end
    ' position
    If startpos% >= endpos% Then Exit Sub

    ' Parition the array into two sections
    splitloc% = QSplit%(startpos%, endpos%)
    ' Now quicksort each of the sections
    QSortNoEvents startpos%, splitloc%
    QSortNoEvents splitloc% + 1, endpos%
    ' That's all there is to it.

End Sub

'
'   Given a portion of the SampleArray starting at startpos%
'   and ending at endpos% (including both startpos% and
'   endpos%), split the array at an arbitrary point.
'   The selected point will be returned as a result by this
'   function.
'   All entries in the array subset from startpos% to this
'   point are guaranteed to be smaller than the entry for this
'   point.
'   All entries in the array subset from this point to endpos%
'   are guaranteed to be larger than the entry for this point.
'
Function QSplit% (ByVal startpos%, ByVal endpos%)

Dim splitloc%
Dim partval#, tval#
Dim fwdscan%, backscan%


    ' If the array is nearly sorted, using the first entry
    ' as the split value is likely to lead to a stack
    ' overflow in VB, so we pick an entry near the center
    ' as the split value, and move it out of the way to
    ' the front of the array (see sidebar)

    If endpos% - startpos% > 5 Then
        splitloc% = (endpos% - startpos%) / 2 + startpos%
        tval# = SampleArray(splitloc%)
        SampleArray(splitloc%) = SampleArray(startpos%)
        SampleArray(startpos%) = tval#
        End If

    ' We'll use the first value as the split value
    partval# = SampleArray(startpos%)

    fwdscan% = startpos% + 1' Index to scan start to end
    backscan% = endpos%     ' Index to scan end to start

    Do ' A left and right scan towards the partition value
        ' Search forward until a value is found that is
        ' larger than the partition value.
        Do While fwdscan% <= endpos% And SampleArray(fwdscan%) < partval#
            fwdscan% = fwdscan% + 1
            Loop
        ' Search backward until a value is found that is
        ' smaller than the partition value.
        Do While backscan% >= startpos% + 1 And SampleArray(backscan%) > partval#
            backscan% = backscan% - 1
            Loop
        If fwdscan% < backscan% Then
            ' These two entries are on the wrong side of
            ' the partition value, so swap them
            tval# = SampleArray(fwdscan%)
            SampleArray(fwdscan%) = SampleArray(backscan%)
            SampleArray(backscan%) = tval#
        Else ' Otherwise, the partition is complete, i.e.
            ' All entries from startpos% to backscan% are
            ' smaller than partval#, all entries from
            ' backscan%+1 to endpos% are larger than tval#
            Exit Do
        End If
    Loop
    ' The split is complete. The entry at position
    ' backscan% is now the first entry smaller than
    ' partval# when scaning from the end. We now swap it
    ' with the partition value that was (as you recall)
    ' the first entry in the array.
    tval# = SampleArray(backscan%)
    SampleArray(backscan%) = SampleArray(startpos%)
    SampleArray(startpos%) = tval#

    ' And return the actual location of the partition value
    QSplit% = backscan%
End Function

' Shows a search using a looping algorithm that is designed
' for use in an event driven environment.  The calling
' function will receive information indicating if the
' search is done or needs to be continued.  The search
' can be cancelled by simply ceasing the calls or
' reset by starting a new search
'
' searchval& is the number to search for - it is only
' used when newsearch is true (-1)
'
' newsearch% is -1 to start a new search, 0 to continue
' an existing search.
'
' Returns the position of the number, or 0 if not found,
' -1 if a search the search is in progress.  The calling
' program will generally keep calling this function until
' it receives a result >= 0
'
'
'
Function SearchEventfully% (searchval, newsearch%)
'
    Static x%
    Static savedsearchval
    Dim cnt%

    If newsearch% Then  ' Setting up a new search
        savedsearchval = searchval
        x% = 1
    End If

    If x% = 0 Then ' Search was not properly started
        SearchEventfully% = x%
        Exit Function
    End If


    ' Refer to the article for information on granularity
    ' of background operations.
    For cnt% = 1 To 100
        ' Here we access the data.  In a real application
        ' this could be a database or file access.
        If savedsearchval = SampleArray(x%) Then
            SearchEventfully% = x%
            Exit Function
        End If

        ' Increment x% and check for the end condition
        x% = x% + 1
        If x% > ARRAYSIZE Then Exit For
    Next cnt%

    If x% > ARRAYSIZE Then
        SearchEventfully% = 0
        x% = 0
    Else
        SearchEventfully% = -1
    End If

End Function

' Shows a search using a looping algorithm that uses
' DoEvents to allow other applications to continue to
' run, and this application to continue to respond to
' events.
'
' searchval is the number to search for
'
' Returns the position of the number, or 0 if not found,
' -1 if a search is already in progress.
'
'
Function SearchWithDoEvents% (searchval)
'
    Dim x%, counter%, temp%

    ' We use this flag to prevent multiple searches from
    ' starting, which could lead to an overflow
    Static NowSearching

    If NowSearching Then
        ' A Search is already in progress - the calling
        ' application should not start a new one due to the
        ' risk of stack overflows.
        SearchWithDoEvents% = -1
        Exit Function
    End If


    For x% = 1 To ARRAYSIZE
        ' Here we access the data.  In a real application
        ' this could be a database or file access.
        If searchval = SampleArray(x%) Then
            SearchWithDoEvents% = x%
            Exit Function
        End If

        counter% = counter% + 1
        If counter% = 10 Then ' Every 10th we do a DoEvents()
            counter% = 0
            temp% = DoEvents()  ' Let events take place
            ' This would be a good place to monitor a
            ' module or global variable for cancellation
            ' of the search
        End If

    Next x%

    ' No value found
    SearchWithDoEvents% = 0


End Function

' Shows a search using a looping algorithm that ties up
' the system.
'
' searchval% is the number to search for
'
' Returns the position of the number, or 0 if not found
'
Function SearchWithoutEvents% (searchval)
    Dim x%, oldmousepointer%

    oldmousepointer% = Screen.MousePointer
    Screen.MousePointer = 11
    For x% = 1 To ARRAYSIZE
        ' Here we access the data.  In a real application
        ' this could be a database or file access.
        If searchval = SampleArray(x%) Then
            SearchWithoutEvents% = x%
            Screen.MousePointer = oldmousepointer%
            Exit Function
        End If
    Next x%

    ' No value found
    SearchWithoutEvents% = 0
    Screen.MousePointer = oldmousepointer%

End Function